
(** pa_breakcont.ml -- c 2008 Andrew I. Schein all rights reserved.
    Camlp4 extension for adding break and continue to OCaml "for" and 
    "while" loops.  *)

(*
Copyright (c) 2008, Andrew I. Schein
All rights reserved.

Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

    * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
    * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
    * Neither the name of the <ORGANIZATION> nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


*)


open Camlp4;;
open Printf;;
open Camlp4.PreCast;;

module S = Stack;;

(* Exceptions are the mechansim for performing what is effectively a goto. 
   Below are lists of exceptions to generate at the top level. *)

let break_exception_name = "Pa_BreakCont_Break"
let cont_exception_name = "Pa_BreakCont_Continue"
  
let stack : (bool ref * bool ref)  Stack.t =  (* break,continue *)
  Stack.create ();;  


let gen_while _loc break_seen cont_seen  e1 e2 = 
  (** appropriate exceptions are added when break (or continue)
      appear in the context *)
  let gen_outer_try the_loop = 
    if break_seen then
      (<:expr< 
         try $the_loop$ 
         with  Pa_BreakCont_Break  -> ()>>)
    else 
      the_loop in
  let gen_inside_loop () = 
    if cont_seen then
      (<:expr<
         try $e2$ with  Pa_BreakCont_Continue  -> ()
           >>)
    else
      e2 in
  let loop = 
    
    (<:expr<while $e1$ do
       $gen_inside_loop ()$
     done>>) in
    gen_outer_try loop;;

let gen_for _loc break_seen cont_seen id start dir  last  e2 = 
  (** appropriate exceptions are added when break (or continue)
      appear in the context *)
  let gen_outer_try the_loop = 
    if break_seen then
      (<:expr< 
         try $the_loop$ 
         with  Pa_BreakCont_Break  -> ()>>)
    else 
      the_loop in
  let gen_inside_loop () = 
    if cont_seen then
      (<:expr<
         try $e2$ with  Pa_BreakCont_Continue  -> ()
           >>)
    else
      e2 in
  let loop = 
    match dir with
         Ast.BTrue ->
           (<:expr<  for $id$ = $start$ to $last$ do 
              $gen_inside_loop ()$
            done>>)
      | Ast.BFalse ->
           (<:expr<  for $id$ = $start$ downto $last$ do 
              $gen_inside_loop ()$
            done>>)
      | _ -> 
          (* not sure how this is used yet. *)
          (failwith "pa_breakcont: trouble figuring out what to do with Ast.Bool on for loop generation!") in
            gen_outer_try loop;;


(* grammar augmentation section *)



DELETE_RULE  Gram Syntax.expr:  "while" ; Syntax.sequence ; "do" ;  Syntax.do_sequence END ;;
DELETE_RULE  Gram Syntax.expr:  "for" ; Syntax.a_LIDENT ;"="; Syntax.sequence  ; Syntax.direction_flag ; Syntax.sequence ; "do" ;  Syntax.do_sequence END ;;


(* direction_flag is not global. Let us redefine it and make it so. *)


EXTEND Gram
  Syntax.expr: LEVEL "top"
  [ [  [ "while" ->
           (Stack.push (ref false, ref false) stack )]
    ; e1 = Syntax.sequence ; "do" ; e2 = Syntax.expr ; "done"  
        -> 
          let (break_seen,continue_seen) = 
            S.top stack in
          let result =
            
            gen_while _loc !break_seen !continue_seen e1 e2 in
          let _ = (Stack.pop stack) in
            result
    ]];

Syntax.expr: LEVEL "top"
  [ [  [ "for" ->
           (Stack.push  (ref false, ref false) stack )]
    ; id = Syntax.a_LIDENT ;  "=" ; start = Syntax.sequence ; direction = Syntax.direction_flag ; finish = Syntax.sequence  ;  "do" ; contents = Syntax.expr ; "done"  
      -> 
        let (break_seen,continue_seen) = 
          S.top stack in
        let result =
          gen_for _loc !break_seen !continue_seen id start direction finish contents in
        let _ = (Stack.pop stack) in
          result
    ]]; 
END;;
 


EXTEND Gram
  Syntax.expr: LEVEL "simple"  
  [[ [ "continue" ->
         if Stack.is_empty stack then
           raise (Stream.Error "continue statement outside of loop.")
         else
           let (_,continue_seen) = Stack.top stack in
           let _ = continue_seen := true in
           <:expr<raise Pa_BreakCont_Continue >> ]
   | [ "break" ->
        if Stack.is_empty stack then
          raise (Stream.Error "break statement outside of loop.")
        else 
          let (break_seen,_) = Stack.top stack in
          let _ = break_seen := true in
            <:expr<raise Pa_BreakCont_Break >> ]
   ]];
END;;


(* initial declarations are generated using AstFilters module *)

let gen_initial_exceptions str_item    =
  ( let loc = 
      Ast.loc_of_str_item str_item in
      <:str_item@loc<
    exception Pa_BreakCont_Break
    exception Pa_BreakCont_Continue
    $str_item$
    >>);;


AstFilters.register_str_item_filter gen_initial_exceptions;;




